unit Locales;

interface

uses
 Forms,
 Classes;

type
 TObjProc = procedure of object;

 TLocales = class(TStringList)
 private
   FDomain: String;
 public
  constructor Create(const Path: String; Domain: String = ''; Bind: Boolean = false);
  procedure GetLangNames(List: TStrings);
  function GetNameIndex(const AName: String): Integer;
  function GetNameCode(const AName: String): String;
  //
  property Domain: string read FDomain;
 end;

function GetLangCodeFromDM(const Language: string): String;
//
procedure TranslateForm(Form: TForm; Language: String; TranslateToo: TObjProc = nil; Domain: String = ''; RestoreLanguage: Boolean = true; RestoreDomain: Boolean = true);

implementation

uses
 SysUtils,
 gnugettext,
 languagecodes;

const
 LocaleFolder = 'locale\';
 MsgFolder = 'LC_MESSAGES\';

 {GNU gettext specific procedure}
function GetLangCodeFromDM(const Language: string): String;
begin
 if getlanguagename(Language)='' then //DM language
  begin
   if Language='russian' then
     Result:='ru'
   else
     if Language='ukrainian' then
        Result:='uk'
     else
       if Language='belarusian' then
         Result:='be'
       else
         if Language='translit' then
           Result:='vo' //translit known as Volapuk
         else
           Result:='en';
  end
 else
   Result:=Language;
end;

procedure TranslateForm(Form: TForm; Language: String; TranslateToo: TObjProc = nil; Domain: String = ''; RestoreLanguage: Boolean = true; RestoreDomain: Boolean = true);
 var
  CurrLang, CurrDomain: String;
begin
 if Assigned(Form) then
  begin
   //save current domain
   if Domain='' then
     CurrDomain:=''
   else
     CurrDomain:=getcurrenttextdomain;
   //save current language
   CurrLang:=GetCurrentLanguage;
   //change to specified domain
   if Domain<>'' then
    begin
     if Domain<>CurrDomain then
       textdomain(Domain);
    end;
   //change to specified language
   if Language<>CurrLang then
     UseLanguage(GetLangCodeFromDM(Language));
   //translate what we need
   RetranslateComponent(Form);
   if Assigned(TranslateToo) then
      TranslateToo;
   //restore domain
   if RestoreDomain then
    begin
     if CurrDomain<>'' then
      begin
       if CurrDomain<>Domain then
         textdomain(CurrDomain);
      end;
    end;
   //restore language
   if RestoreLanguage then
    begin
     if CurrLang<>Language then
       UseLanguage(CurrLang);
    end;
  end;
end;

{ TLocales }

constructor TLocales.Create(const Path: String; Domain: String = ''; Bind: Boolean = false);
 var
   SearchFolder, s: String;
   i: Integer;
   sr: TSearchRec;
   Found: Boolean;
begin
 inherited Create;
 //first is always built-in English
 Add('en=English (built in)');
 //scan locale folder for subfolders
 SearchFolder:=IncludeTrailingPathDelimiter(Path)+LocaleFolder;
 if DirectoryExists(SearchFolder) then
  begin
   i:=FindFirst(SearchFolder+'*.*', faDirectory, sr);
   if Domain='' then //default domain
     FDomain:=getcurrenttextdomain
   else
    begin
     FDomain:=Domain;
     if Bind then
       bindtextdomain(FDomain, SearchFolder);
    end;
   while i=0 do
    begin
     s:=getlanguagename(sr.Name);
     //if subfolder name has language name
     if s<>'' then
      begin
       Found:=FileExists(SearchFolder+sr.Name+'\'+MsgFolder+FDomain+'.mo');
       if Found then
         Add(sr.Name+'='+s);
      end;
     i:=FindNext(sr);
    end;
   FindClose(sr);
  end;
end;

procedure TLocales.GetLangNames(List: TStrings);
 var
   i: Integer;
begin
 if Assigned(List) then
  begin
   List.Clear;
   for i:=0 to Count-1 do
     List.Add(ValueFromIndex[i]);
  end;
end;

function TLocales.GetNameIndex(const AName: String): Integer;
begin
 Result:=Count-1;
 while Result>=0 do
  begin
   if SameText(AName, ValueFromIndex[Result]) then
     Break
   else
     Dec(Result);
  end;
end;

function TLocales.GetNameCode(const AName: String): String;
 var
   i: Integer;
begin
 i:=GetNameIndex(AName);
 if i<0 then
   Result:=''
 else
   Result:=Names[i];
end;

end.
